home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / bcomp / recon.scm < prev    next >
Text File  |  1995-10-13  |  14KB  |  384 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4.  
  5. ; Rudimentary type reconstruction, hardly worthy of the name.
  6.  
  7. ; Currently, NODE-TYPE is called in two places.  One is to determine
  8. ; the type of the right-hand side of a DEFINE for a variable that is
  9. ; never assigned, so uses of the variable can be checked later.  The
  10. ; other is when compiling a call, to check types of arguments and
  11. ; produce warning messages.
  12.  
  13. ; This is heuristic, to say the least.  It's not clear what the right
  14. ; interface or formalism is for Scheme; I'm still experimenting.
  15.  
  16. ; Obviously we can't do Hindley-Milner inference.  Not only does
  17. ; Scheme have subtyping, but it also has dependent types up the wazoo.
  18. ; For example, the following is perfectly correct Scheme:
  19. ;
  20. ;   (define (foo x y) (if (even? x) (car y) (vector-ref y 3)))
  21.  
  22.  
  23. (define (node-type node env)
  24.   ;; Ignore env, since we don't ever call CLASSIFY or LOOKUP.
  25.   (reconstruct node 'fast any-values-type))
  26.  
  27. (define (reconstruct-type node env)
  28.   (reconstruct node '() any-values-type))
  29.  
  30. (define (reconstruct node constrained want-type)
  31.   (cond ((node? node)
  32.          ((operator-table-ref reconstructors (node-operator-id node))
  33.           node constrained want-type))
  34.         ((pair? node) any-values-type)
  35.         ((name? node) value-type)
  36.         (else (constant-type node))))
  37.  
  38. (define reconstructors
  39.   (make-operator-table (lambda (node constrained want-type)
  40.                          (reconstruct-call node constrained want-type))))
  41.  
  42. (define (define-reconstructor name type proc)
  43.   (operator-define! reconstructors name type proc))
  44.  
  45.  
  46. (define-reconstructor 'lambda syntax-type
  47.   (lambda (node constrained want-type)
  48.     (if (eq? constrained 'fast)
  49.         any-procedure-type
  50.         (let ((form (node-form node))
  51.               (var-nodes (node-ref node 'var-nodes))
  52.               (want-result (careful-codomain want-type)))
  53.           (let ((formals (cadr form)))
  54.             (if var-nodes
  55.                 (let* ((alist (map (lambda (node) (cons node value-type))
  56.                                    var-nodes))
  57.                        ;; We can't do (append alist constrained) because the
  58.                        ;; lambda might not be called...
  59.                        (cod (reconstruct-body (cddr form)
  60.                                               alist
  61.                                               want-result)))
  62.                   (procedure-type (if (n-ary? formals)
  63.                                       any-values-type ;lose
  64.                                       (make-some-values-type (map cdr alist)))
  65.                                   cod
  66.                                   #t))
  67.                 (procedure-type
  68.                  (if (n-ary? formals)
  69.                      any-values-type    ;lose
  70.                      (make-some-values-type (map (lambda (f) value-type)
  71.                                                  formals)))
  72.                  (reconstruct-body (cddr form) constrained want-result)
  73.                  #t)))))))
  74.  
  75. (define (careful-codomain proc-type)
  76.   (if (procedure-type? proc-type)
  77.       (procedure-type-codomain proc-type)
  78.       any-values-type))
  79.  
  80. (define (reconstruct-body body constrained want-type)
  81.   (if (null? (cdr body))
  82.       (reconstruct (car body) constrained want-type)
  83.       any-values-type))
  84.  
  85. (define operator/name (get-operator 'name))
  86.  
  87. (define-reconstructor 'name 'leaf
  88.   (lambda (node constrained want-type)
  89.     (if (eq? constrained 'fast)
  90.         (reconstruct-name node)
  91.         (let ((z (assq node constrained)))
  92.           (if z
  93.               (let ((type (meet-type (cdr z) want-type)))
  94.                 (begin (set-cdr! z type)
  95.                        type))
  96.               (reconstruct-name node))))))
  97.  
  98. (define (reconstruct-name node)
  99.   (let ((probe (node-ref node 'binding)))
  100.     (if (binding? probe)
  101.         (let ((t (binding-type probe)))
  102.           (cond ((variable-type? t) (variable-value-type t))
  103.                 ((subtype? t value-type) t)
  104.                 (else value-type)))
  105.         value-type)))
  106.  
  107. (define (reconstruct-call node constrained want-type)
  108.   (let* ((form (node-form node))
  109.          (op-type (reconstruct (car form)
  110.                                constrained
  111.                                (procedure-type any-arguments-type
  112.                                                want-type
  113.                                                #f)))
  114.          (args (cdr form))
  115.          (lose (lambda ()
  116.                  (for-each (lambda (arg)
  117.                              (examine arg constrained value-type))
  118.                            args))))
  119.     (if (procedure-type? op-type)
  120.         (begin (if (restrictive? op-type)
  121.                    (let loop ((args args)
  122.                               (dom (procedure-type-domain op-type)))
  123.                      (if (not (or (null? args)
  124.                                   (empty-rail-type? dom)))
  125.                          (begin (examine (car args)
  126.                                          constrained
  127.                                          (head-type dom))
  128.                                 (loop (cdr args) (tail-type dom)))))
  129.                    (lose))
  130.                (procedure-type-codomain op-type))
  131.         (begin (lose)
  132.                any-values-type))))
  133.  
  134. (define-reconstructor 'literal 'leaf
  135.   (lambda (node constrained want-type)
  136.     (constant-type (node-form node))))
  137.  
  138. (define-reconstructor 'quote syntax-type
  139.   (lambda (node constrained want-type)
  140.     (constant-type (cadr (node-form node)))))
  141.  
  142. (define-reconstructor 'if syntax-type
  143.   (lambda (node constrained want-type)
  144.     (let ((form (node-form node)))
  145.       (examine (cadr form) constrained value-type)
  146.       ;; Fork off two different constrain sets
  147.       (let ((con-alist (fork-constraints constrained))
  148.             (alt-alist (fork-constraints constrained)))
  149.         (let ((con-type (reconstruct (caddr form) con-alist want-type))
  150.               (alt-type (reconstruct (cadddr form) alt-alist want-type)))
  151.           (if (pair? constrained)
  152.               (for-each (lambda (c1 c2 c)
  153.                           (set-cdr! c (join-type (cdr c1) (cdr c2))))
  154.                         con-alist
  155.                         alt-alist
  156.                         constrained))
  157.           (join-type con-type alt-type))))))
  158.  
  159.  
  160. (define (fork-constraints constrained)
  161.   (if (pair? constrained)
  162.       (map (lambda (x) (cons (car x) (cdr x)))
  163.            constrained)
  164.       constrained))
  165.  
  166. (define-reconstructor 'begin syntax-type
  167.   (lambda (node constrained want-type)
  168.     ;; This is unsound - there might be a throw out of some subform
  169.     ;; other than the final one.
  170.     (do ((forms (cdr (node-form node)) (cdr forms)))
  171.         ((null? (cdr forms))
  172.          (reconstruct (car forms) constrained want-type))
  173.       (examine (car forms) constrained any-values-type))))
  174.  
  175. (define (examine node constrained want-type)
  176.   (if (pair? constrained)
  177.       (reconstruct node constrained want-type)
  178.       want-type))
  179.  
  180. (define-reconstructor 'set! syntax-type
  181.   (lambda (node constrained want-type)
  182.     (examine (caddr (node-form node)) constrained value-type)
  183.     unspecific-type))
  184.  
  185. (define-reconstructor 'letrec syntax-type
  186.   (lambda (node constrained want-type)
  187.     (let ((form (node-form node)))
  188.       (if (eq? constrained 'fast)
  189.           (reconstruct (last form) 'fast want-type)
  190.           (let ((types (map (lambda (spec)
  191.                               (reconstruct (cadr spec) constrained value-type))
  192.                             (cadr form))))
  193.             (reconstruct (last form)
  194.                          (let ((nodes (node-ref node 'var-nodes)))
  195.                            (if nodes
  196.                                (append (map cons nodes types)
  197.                                        constrained)
  198.                                constrained))
  199.                          want-type))))))
  200.  
  201. (define-reconstructor 'primitive-procedure syntax-type
  202.   (lambda (node constrained want-type)
  203.     (operator-type (get-operator (cadr (node-form node))))))    ;mumble
  204.  
  205. (define-reconstructor 'loophole syntax-type
  206.   (lambda (node constrained want-type)
  207.     (let ((args (cdr (node-form node))))
  208.       (examine (cadr args) constrained any-values-type)
  209.       (sexp->type (schemify (car args)) #t))))  ;Foo
  210.  
  211. (define (node->type node)
  212.   (if (node? node)
  213.       (let ((form (node-form node)))
  214.         (if (pair? form)
  215.             (map node->type form)
  216.             (desyntaxify form)))
  217.       (desyntaxify node)))
  218.  
  219. (define-reconstructor 'define syntax-type
  220.   (lambda (node constrained want-type)
  221.     ':definition))
  222.  
  223. (define-reconstructor 'define-syntax syntax-type
  224.   (lambda (node constrained want-type)
  225.     ':definition))
  226.  
  227.  
  228. (define call-node? (node-predicate 'call))
  229. (define name-node? (node-predicate 'name))
  230. (define begin-node? (node-predicate 'begin))
  231.  
  232.  
  233.  
  234.  
  235.  
  236. ; --------------------
  237. ; Primitive procedures:
  238.  
  239. (define-reconstructor 'values any-procedure-type
  240.   (lambda (node constrained want-type)
  241.     (make-some-values-type (map (lambda (node)
  242.                                   (meet-type
  243.                                    (reconstruct node constrained value-type)
  244.                                    value-type))
  245.                                 (cdr (node-form node))))))
  246.  
  247. (define-reconstructor 'call-with-values
  248.                       (proc ((proc () any-values-type #f)
  249.                              any-procedure-type)
  250.                             any-values-type)
  251.   (lambda (node constrained want-type)
  252.     (let* ((args (cdr (node-form node)))
  253.            (thunk-type (reconstruct (car args)
  254.                                     constrained
  255.                                     (procedure-type empty-rail-type
  256.                                                     any-values-type
  257.                                                     #f))))
  258.       (careful-codomain
  259.             (reconstruct (cadr args)
  260.                          constrained
  261.                          (procedure-type (careful-codomain thunk-type)
  262.                                          any-values-type
  263.                                          #f))))))
  264.  
  265. (define (reconstruct-apply node constrained want-type)
  266.   (let* ((args (cdr (node-form node)))
  267.          (proc-type (reconstruct (car args)
  268.                                  constrained
  269.                                  any-procedure-type)))
  270.     (for-each (lambda (arg) (examine arg constrained value-type))
  271.               (cdr args))
  272.     (careful-codomain proc-type)))
  273.  
  274. (define-reconstructor 'apply
  275.     (proc (any-procedure-type &rest value-type) any-values-type)
  276.   reconstruct-apply)
  277.  
  278. (define-reconstructor 'primitive-catch
  279.                       (proc ((proc (escape-type) any-values-type #f))
  280.                             any-values-type)
  281.   reconstruct-apply)
  282.  
  283.  
  284. ; --------------------
  285. ; Types of simple primitives.
  286.  
  287. (define (declare-operator-type ops type)
  288.   (if (list? ops)
  289.       (for-each (lambda (op) (get-operator op type))
  290.                 ops)
  291.       (get-operator ops type)))
  292.  
  293. (declare-operator-type 'with-continuation
  294.                        (proc (escape-type (proc () any-values-type #f))
  295.                              any-arguments-type))
  296.  
  297. (declare-operator-type 'eq?
  298.                        (proc (value-type value-type) boolean-type))
  299.  
  300. (declare-operator-type '(number? integer? rational? real? complex?
  301.                                  char? eof-object? input-port? output-port?)
  302.                        (proc (value-type) boolean-type))
  303.  
  304. (declare-operator-type 'exact?
  305.                        (proc (number-type) boolean-type))
  306.  
  307. (declare-operator-type 'exact->inexact (proc (exact-type) inexact-type))
  308. (declare-operator-type 'inexact->exact (proc (inexact-type) exact-type))
  309.  
  310. (declare-operator-type '(exp log sin cos tan asin acos sqrt)
  311.                        (proc (number-type) number-type))
  312.  
  313. (declare-operator-type '(atan)
  314.                        (proc (number-type number-type) number-type))
  315.  
  316. (declare-operator-type '(floor)
  317.                        (proc (real-type) integer-type))
  318.  
  319. (declare-operator-type '(real-part imag-part angle magnitude)
  320.                        (proc (complex-type) real-type))
  321.  
  322. (declare-operator-type '(numerator denominator)
  323.                        (proc (rational-type) integer-type))
  324.  
  325. (declare-operator-type '(+ * - /)
  326.                        (proc (number-type number-type) number-type))
  327.  
  328. (declare-operator-type '(= <)
  329.                        (proc (real-type real-type) boolean-type))
  330.  
  331. (declare-operator-type '(make-polar make-rectangular)
  332.                        (proc (real-type real-type) complex-type))
  333.  
  334. (declare-operator-type '(quotient remainder)
  335.                        (proc (integer-type integer-type) integer-type))
  336.  
  337. (declare-operator-type '(bitwise-not)
  338.                        (proc (exact-integer-type) exact-integer-type))
  339.  
  340. (declare-operator-type '(bitwise-and bitwise-ior bitwise-xor
  341.                          arithmetic-shift)
  342.                        (proc (exact-integer-type exact-integer-type)
  343.                              exact-integer-type))
  344.  
  345. (declare-operator-type '(char=? char<?)
  346.                        (proc (char-type char-type) boolean-type))
  347.  
  348. (declare-operator-type 'char->ascii
  349.                        (proc (char-type) exact-integer-type))
  350.  
  351. (declare-operator-type 'ascii->char
  352.                        (proc (exact-integer-type) char-type))
  353.  
  354. (declare-operator-type 'string=?
  355.                        (proc (string-type string-type) boolean-type))
  356.  
  357. (declare-operator-type 'open-port
  358.                        ;; Can return #f
  359.                        (proc (string-type exact-integer-type) value-type))
  360.  
  361. (declare-operator-type 'cons (proc (value-type value-type) pair-type))
  362.  
  363. (declare-operator-type 'intern (proc (string-type vector-type) symbol-type))
  364.  
  365. ; Can't do I/O until the meta-types interface exports input-port-type and
  366. ; output-port-type.
  367.  
  368. (define (constant-type x)
  369.   (cond ((number? x)
  370.          (meet-type (if (exact? x) exact-type inexact-type)
  371.                     (cond ((integer? x) integer-type)
  372.                           ((rational? x) rational-type)
  373.                           ((real? x) real-type)
  374.                           ((complex? x) complex-type)
  375.                           (else number-type))))
  376.         ((boolean? x) boolean-type)
  377.         ((pair? x) pair-type)
  378.         ((string? x) string-type)
  379.         ((char? x) char-type)
  380.         ((null? x) null-type)
  381.         ((symbol? x) symbol-type)
  382.         ((vector? x) vector-type)
  383.         (else value-type)))
  384.